(in-package :cl-gdbm)

(defmacro once-only ((&rest names) &body body)
  ;; Check that all of the NAMES are symbols. If not, raise an error.
  (let ((bad-name (find-if-not #'symbolp names)))
    (when bad-name
      (error "ONCE-ONLY expected a symbol but got ~S" bad-name)))
  ;; Do not touch this code unless you really know what you're doing.
  (let ((gensyms (loop for name in names collect (gensym (string name)))))
    `(let (,@(loop for g in gensyms
                   for name in names
                   collect `(,g (gensym ,(string name)))))
       `(let (,,@(loop for g in gensyms for n in names
                       collect ``(,,g ,,n)))
          ,(let (,@(loop for n in names for g in gensyms
                         collect `(,n ,g)))
             ,@body)))))


(defmacro with-unique-names ((&rest bindings) &body body)
  "Executes a series of forms with each var bound to a fresh,
uninterned symbol. See http://www.cliki.net/WITH-UNIQUE-NAMES"
  `(let ,(mapcar #'(lambda (binding)
                     (destructuring-bind (var prefix)
			 (if (consp binding)
			     binding
			     (list binding binding))
		       (if (symbolp var)
			   `(,var (gensym ,(format nil "~A" prefix)))
			   (error 'type-error
				  :datum var
				  :expected-type 'symbol))))
                 bindings)
    ,@body))


(defmacro aif (test then &optional else)
  `(let ((it ,test))
     (if it ,then ,else)))

(defmacro awhen (test-form &body body)
  `(aif ,test-form
        (progn ,@body)))


(defun collect (thing)
  "Collect THING in the context established by the COLLECTING macro"
  (error "Can't collect ~S outside the context of the COLLECTING macro"
	 thing))

(defmacro collecting (&body body)
  "Collect things into a list forwards. Within the body of this macro,
the COLLECT function will collect its argument into the list returned
by COLLECTING."
  (with-unique-names (collector tail)
    `(let (,collector ,tail)
      (labels ((collect (thing)
		 (if ,collector
		     (setf (cdr ,tail)
			   (setf ,tail (list thing)))
		     (setf ,collector
			   (setf ,tail (list thing))))))
	,@body)
      ,collector)))